home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / pxg11.arc / PXG11.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1985-10-06  |  13.6 KB  |  639 lines

  1.  
  2.  
  3. (* -------------------------------------------------------
  4.  *
  5.  *   PXG - A Pascal Expert Generator
  6.  *
  7.  *   By Samuel H. Smith,  Public Domain Material
  8.  *
  9.  *   Version 1.0, 4-Oct-85
  10.  *      Initial public domain release
  11.  *
  12.  *   Version 1.1, 6-Oct-85
  13.  *      This version uses a new, more compact format for .KDB files
  14.  *      and is not compatible with old .KDB files.
  15.  *
  16.  *)
  17.  
  18. {$D-,U+,R+}
  19.  
  20.  
  21. program pascal_expert_generator;
  22.  
  23. type
  24.    anystring = string[80];
  25.  
  26.    treeptr = ^tree;           {this is the basic structure of the}
  27.    tree = record              {knowledge base tree}
  28.  
  29.       question:   anystring;      {question to ask at this node in the tree}
  30.       ifyes:      treeptr;           {subtree if answer is yes}
  31.       ifno:       treeptr;           {subtree if answer is no}
  32.  
  33.       conclusion: anystring;      {conclusion if there is no question}
  34.  
  35.    end;
  36.  
  37.  
  38.  
  39. var
  40.    title:  anystring;    {the title of the current knowledge base}
  41.  
  42.    root:   treeptr;      {the root of the knowledge tree}
  43.  
  44.    fd:     text[1024];   {file for read/write tree to disk}
  45.  
  46.    line:   anystring;    {a working line buffer}
  47.  
  48.    saved:  boolean;      {has the current knowledge base been saved?}
  49.  
  50.  
  51.  
  52. (* -------------------------------------------------------
  53.  *
  54.  *   ask a yes/no question
  55.  *
  56.  *   returns true if the answer is yes
  57.  *
  58.  *)
  59.  
  60. function ask(question: anystring): boolean;
  61. var
  62.    answer: char;
  63. begin
  64.    repeat
  65.       write(question,' (Y/N) ');
  66.  
  67.       read(kbd,answer);
  68.       answer := upcase(answer);
  69.       writeln(answer);
  70.  
  71.       if not (answer in ['Y','N']) then
  72.          writeln('Please answer the question!');
  73.  
  74.    until answer in ['Y','N'];
  75.  
  76.    ask := (answer = 'Y');
  77. end;
  78.  
  79.  
  80.  
  81. (* -------------------------------------------------------
  82.  *
  83.  *   make a conclusion
  84.  *
  85.  *)
  86.  
  87. procedure conclude(conc: anystring);
  88. begin
  89.    writeln;
  90.    writeln('Conclusion: ',conc);
  91.    writeln;
  92. end;
  93.  
  94.  
  95.  
  96. (* -------------------------------------------------------
  97.  *
  98.  *   learn a new rule
  99.  *
  100.  *   entered when an incorrect conclusion is drawn
  101.  *   moves the current conclusion down the 'no' branch of the tree
  102.  *   makes a new question and moves it's conclusion down the 'yes' branch
  103.  *
  104.  *)
  105.  
  106. procedure learn(var node: treeptr);
  107. var
  108.    temptree: treeptr;
  109.  
  110. begin
  111.    saved := false;
  112.  
  113.    with node^ do
  114.    begin
  115.       new(ifno);       {initialize the new subtrees}
  116.       with ifno^ do
  117.       begin
  118.          ifyes      := nil;
  119.          ifno       := nil;
  120.          question   := node^.question;    {the ifno subtree inherits the}
  121.          conclusion := node^.conclusion;  {question and conclusion that}
  122.       end;                                {used to be at this node}
  123.  
  124.       new(ifyes);
  125.       with ifyes^ do
  126.       begin
  127.          ifyes      := nil;
  128.          ifno       := nil;
  129.          question   := '';
  130.       end;
  131.  
  132.  
  133.       {now gather the information needed to enter a new question and
  134.        conclusion into the tree}
  135.  
  136.       writeln;
  137.       writeln('Please enter the correct conclusion:');
  138.       write('> ');
  139.       readln(conclusion);
  140.       ifyes^.conclusion := conclusion;
  141.  
  142.       repeat
  143.          writeln;
  144.          writeln('Please enter a new question.  Phrase the question');
  145.          writeln('so that when answered "yes" it gives the conclusion: ');
  146.          writeln('   ',ifyes^.conclusion);
  147.          writeln('and that when answered "no" gives the conclusion:');
  148.          writeln('   ',ifno^.conclusion);
  149.  
  150.          writeln;
  151.          writeln('Enter "X" to exchange the "yes" and "no" conclusions,');
  152.          writeln('otherwise enter the actual question.');
  153.          write('> ');
  154.          readln(question);
  155.          question[1] := upcase(question[1]);
  156.          writeln;
  157.  
  158.          if question = 'X' then
  159.          begin
  160.             temptree := ifno;
  161.             ifno := ifyes;
  162.             ifyes := temptree;
  163.          end;
  164.  
  165.       until question <> 'X';
  166.    end;
  167. end;
  168.  
  169.  
  170.  
  171. (* -------------------------------------------------------
  172.  *
  173.  *   solve a problem with a knowledge tree
  174.  *
  175.  *   makes a conclusion if there is no question in the current node.
  176.  *   otherwise, it asks the question and then tries to solve
  177.  *   the remaining subtree.
  178.  *   will learn a new fact if an incorrect conclusion is drawn.
  179.  *
  180.  *)
  181.  
  182. procedure solvetree(node: treeptr);
  183. begin
  184.    with node^ do
  185.    begin
  186.       if question <> '' then   {ask the question if there is one}
  187.       begin
  188.          if ask(question) then
  189.             solvetree(ifyes)      {decide which branch of the tree}
  190.          else                     {to solve based on the answer}
  191.             solvetree(ifno);
  192.       end
  193.       else
  194.  
  195.       begin           {there is no question; just make a conclusion}
  196.          conclude(conclusion);
  197.  
  198.          if ask('Is this the right conclusion?') = false then
  199.             learn(node);
  200.       end;
  201.  
  202.    end;
  203. end;
  204.  
  205.  
  206.  
  207. (* -------------------------------------------------------
  208.  *
  209.  *   list all of the knowledge contained in a knowledge tree
  210.  *
  211.  *)
  212.  
  213. procedure disptree(level: integer;  node: treeptr);
  214. begin
  215.    with node^ do
  216.    begin
  217.       if question <> '' then
  218.       begin
  219.          writeln('':level,'If ''',question,''' is true:');
  220.          disptree(level+3,ifyes);
  221.  
  222.          writeln;
  223.          writeln('':level,'If ''',question,''' is false:');
  224.          disptree(level+3,ifno);
  225.       end
  226.       else
  227.          writeln('':level,conclusion)
  228.    end;
  229. end;
  230.  
  231.  
  232.  
  233. (* -------------------------------------------------------
  234.  *
  235.  *   write a node in the knowledge tree to a file
  236.  *
  237.  *)
  238.  
  239. procedure writenode(level: integer; node: treeptr);
  240. begin
  241.    with node^ do
  242.    begin
  243.       if question <> '' then
  244.       begin
  245.          writeln(fd,'Q:',question);
  246.          write(fd,'':level,'Y');
  247.          writenode(level+1,ifyes);
  248.  
  249.          write(fd,'':level,'N');
  250.          writenode(level+1,ifno);
  251.       end
  252.       else
  253.          writeln(fd,'C:',conclusion);
  254.    end;
  255. end;
  256.  
  257.  
  258.  
  259. (* -------------------------------------------------------
  260.  *
  261.  *   write the entire knowledge tree to a file
  262.  *
  263.  *)
  264.  
  265. procedure writetree;
  266. begin
  267.    write('Enter the name of the file to write to [.KDB]: ');
  268.    readln(line);
  269.    if line = '' then
  270.       exit;
  271.  
  272.    if pos('.',line) = 0 then
  273.       line := line + '.KDB';
  274.  
  275.    assign(fd,line);
  276.  
  277. {$I-}
  278.    rewrite(fd);
  279.    writeln(fd,title);
  280.    writenode(0,root);
  281.    close(fd);
  282.  
  283.    if ioresult <> 0 then
  284.       writeln('Error writing file!')
  285.    else
  286.       saved := true;
  287. {$I+}
  288.  
  289. end;
  290.  
  291.  
  292.  
  293. (* -------------------------------------------------------
  294.  *
  295.  *   read a node of the knowledge tree from a file
  296.  *   and verify that the file is valid
  297.  *
  298.  *)
  299.  
  300. procedure readnode(node: treeptr);
  301. var
  302.    c: char;
  303.  
  304.    procedure expect(message: anystring);
  305.    begin
  306.       repeat
  307.          read(fd,c);
  308.       until c <> ' ';
  309.  
  310.       if c <> message then
  311.          writeln('"',message,'" expected, "',c,'" found.');
  312.    end;
  313.  
  314. begin
  315.    with node^ do
  316.    begin
  317.  
  318.       read(fd,c);
  319.       if c = 'Q' then
  320.       begin
  321.          conclusion := '';
  322.          expect(':');
  323.          readln(fd,question);
  324.  
  325.          expect('Y');
  326.          new(ifyes);
  327.          readnode(ifyes);
  328.  
  329.          expect('N');
  330.          new(ifno);
  331.          readnode(ifno);
  332.       end
  333.       else
  334.  
  335.       begin
  336.          if c <> 'C' then
  337.             writeln('"C" expected, "',c,'" found.');
  338.  
  339.          expect(':');
  340.          readln(fd,conclusion);
  341.       end;
  342.    end;
  343. end;
  344.  
  345.  
  346.  
  347. (* -------------------------------------------------------
  348.  *
  349.  *   read a new knowledge tree from a file
  350.  *
  351.  *)
  352.  
  353. procedure readtree;
  354. begin
  355.  
  356.    {if there is anything in the current knowledge tree, then see if}
  357.    {the user wants to save it}
  358.  
  359.    if not saved then
  360.       if ask('Do you want to save the current knowledge base?') then
  361.          writetree;
  362.  
  363.    write('Enter the name of the file to read from [.KDB]: ');
  364.    readln(line);
  365.    if line = '' then
  366.       exit;
  367.  
  368.    if pos('.',line) = 0 then
  369.       line := line + '.KDB';
  370.  
  371.    assign(fd,line);
  372.  
  373. {$I-}
  374.    reset(fd);
  375.    if ioresult <> 0 then
  376.       writeln('File not found!')
  377.    else
  378.  
  379.    begin
  380.       readln(fd,title);
  381.       readnode(root);
  382.       close(fd);
  383.    end;
  384.  
  385.    if ioresult <> 0 then
  386.       writeln('Error reading file!');
  387. {$I+}
  388.  
  389.    saved := true;
  390.  
  391. end;
  392.  
  393.  
  394.  
  395.  
  396. (* -------------------------------------------------------
  397.  *
  398.  *   generate a program fragment for the current node in the knowledge tree
  399.  *
  400.  *)
  401.  
  402. procedure prognode(level: integer;  node: treeptr);
  403. begin
  404.    with node^ do
  405.    begin
  406.       if question <> '' then
  407.       begin
  408.          writeln(fd,'':level,'if ask(''',question,''') = true then');
  409.          prognode(level+3,ifyes);
  410.  
  411.          writeln(fd);
  412.          writeln(fd,'':level,'else    {',question,' = false}');
  413.          prognode(level+3,ifno);
  414.       end
  415.       else
  416.          writeln(fd,'':level,'conclude(''',conclusion,''')');
  417.    end;
  418. end;
  419.  
  420.  
  421.  
  422. (* -------------------------------------------------------
  423.  *
  424.  *   generate a program to walk the knowledge tree
  425.  *
  426.  *)
  427.  
  428. procedure progtree;
  429. begin
  430.    write('Enter the name of the file to save the program in [.PAS]: ');
  431.    readln(line);
  432.    if line = '' then
  433.       exit;
  434.  
  435.    if pos('.',line) = 0 then
  436.       line := line + '.PAS';
  437.  
  438.    assign(fd,line);
  439.  
  440. {$I-}
  441.    reset(fd);
  442. {$I+}
  443.  
  444.    if ioresult = 0 then
  445.    begin
  446.       close(fd);
  447.       if ask('The file '+line+' exists!   Overwrite it?') = false then
  448.          exit;
  449.    end;
  450.  
  451. {$I-}
  452.    rewrite(fd);
  453.    writeln(fd);
  454.    writeln(fd,'{Expert program ',line,' generated by PXG}');
  455.    writeln(fd);
  456.    writeln(fd,'{$I PXG.INC}');
  457.    writeln(fd);
  458.    writeln(fd,'begin');
  459.    writeln(fd,'   repeat');
  460.    writeln(fd,'      writeln;');
  461.    writeln(fd,'      writeln(''',title,''');');
  462.    writeln(fd,'      writeln;');
  463.    writeln(fd);
  464.    prognode(6,root);
  465.    writeln(fd);
  466.    writeln(fd,'   until ask(''Run again?'') = false;');
  467.    writeln(fd,'end.');
  468.    close(fd);
  469.  
  470.    if ioresult <> 0 then
  471.       writeln('Error writing file!')
  472.    else
  473.  
  474.    begin
  475.       writeln;
  476.       writeln('Use Turbo Pascal to compile ',line);
  477.       writeln;
  478.    end;
  479.  
  480. {$I+}
  481.  
  482. end;
  483.  
  484.  
  485.  
  486. (* -------------------------------------------------------
  487.  *
  488.  *   initialize a new knowledge tree
  489.  *
  490.  *)
  491.  
  492. procedure inittree;
  493. begin
  494.    new(root);
  495.    with root^ do
  496.    begin
  497.       ifyes      := nil;
  498.       ifno       := nil;
  499.       question   := '';
  500.       conclusion := 'No conclusion';
  501.    end;
  502.  
  503.    saved := true;
  504.    title := 'Default knowledge base';
  505.  
  506. end;
  507.  
  508.  
  509.  
  510. (* -------------------------------------------------------
  511.  *
  512.  *   initialize a new knowledge tree
  513.  *
  514.  *)
  515.  
  516. procedure newtree;
  517. begin
  518.  
  519.    {if there is anything in the current knowledge tree, then see if}
  520.    {the user wants to save it}
  521.  
  522.    if not saved then
  523.       if ask('Do you want to save the current knowledge base?') then
  524.          writetree;
  525.  
  526.    writeln('Enter the title of the new expert:');
  527.    write('> ');
  528.    readln(title);
  529.  
  530. end;
  531.  
  532.  
  533.  
  534. (* -------------------------------------------------------
  535.  *
  536.  *   help - give some help
  537.  *
  538.  *)
  539.  
  540. procedure help;
  541. begin
  542.    clrscr;
  543.    writeln;
  544.    writeln('PXG - A Pascal Expert Generator');
  545.    writeln;
  546.    writeln('This program allows you to prepare a set of rules for a');
  547.    writeln('decision-tree based expert system.');
  548.    writeln;
  549.    writeln('You teach the expert by repeatedly "Learning" new facts. ');
  550.    writeln('When you have your rules working properly, you can generate ');
  551.    writeln('a stand-alone expert program in turbo pascal!');
  552.    writeln;
  553.    writeln('Actions:');
  554.    writeln('   New          Create a new knowledge base');
  555.    writeln('   Read         Read a knowledge base from a disk file');
  556.    writeln('   Write        Write the current knowledge base to a file');
  557.    writeln('   Display      Display the rules in the current knowledge base');
  558.    writeln('   Program      Generate an expert program from this knowledge base');
  559.    writeln('   Learn        Test this knowledge base and learn new rules');
  560.    writeln('   Quit         Exit to the system');
  561.    writeln;
  562.  
  563. end;
  564.  
  565.  
  566.  
  567. (* -------------------------------------------------------
  568.  *
  569.  *   main program
  570.  *   select expert commands and process them
  571.  *
  572.  *)
  573.  
  574. var
  575.    command:  char;
  576.  
  577. begin
  578.    clrscr;
  579.    writeln;
  580.    writeln('PXG - A Pascal Expert Generator');
  581.    writeln;
  582.    writeln('This program allows you to prepare a set of rules for a');
  583.    writeln('decision-tree based expert system.');
  584.    writeln;
  585.    writeln('You teach the expert by repeatedly "Learning" new facts. ');
  586.    writeln('When you have your rules working properly, you can generate ');
  587.    writeln('a stand-alone expert program in turbo pascal!');
  588.    writeln;
  589.    writeln('By Samuel H. Smith,  Public Domain Material');
  590.    writeln('Version 1.1, 6-Oct-85');
  591.  
  592.    sound(3000);
  593.    delay(100);
  594.    nosound;
  595.  
  596.    delay(3000);
  597.    help;
  598.  
  599.    inittree;
  600.  
  601.    repeat
  602.       writeln;
  603.       writeln('Working on:');
  604.       writeln('   ',title);
  605.       writeln;
  606.       write('Action:  New, Read, Write, Display, Program, Learn, Quit, ?: ');
  607.  
  608.       read(kbd,command);
  609.       command := upcase(command);
  610.       writeln(command);
  611.       writeln;
  612.  
  613.       case command of
  614.          'N':  newtree;
  615.          'R':  readtree;
  616.          'W':  writetree;
  617.          'D':  disptree(3,root);
  618.          'P':  progtree;
  619.          'L':  solvetree(root);
  620.          '?':  help;
  621.          'Q':  ;
  622.  
  623.          else  writeln('What?   Type "?" for help.');
  624.       end;
  625.  
  626.    until command = 'Q';
  627.  
  628.  
  629.    {if there is anything in the current knowledge tree, then see if}
  630.    {the user wants to save it}
  631.  
  632.    if not saved then
  633.       if ask('Do you want to save the current knowledge base?') then
  634.          writetree;
  635.  
  636.    writeln('Goodbye.');
  637. end.
  638.  
  639.